;;; General use parser -*- Mode:LISP; Package:ZWEI; Base:8 -*-
;;; ** (c) Copyright 1981 Massachusetts Institute of Technology **

(DEFSTRUCT (PARSE-GRAMMAR :ARRAY :NAMED :CONC-NAME (:ALTERANT NIL))
  NAME                                          ;A symbol
  TERMINALS                                     ;List of lexemes and EOF
  SYMBOLS                                       ;Above plus all intermediates
  PRODUCTIONS                                   ;List of all productions
  TOP-LEVEL-PRODUCTION                          ;Augmented top-level production
  ACTIONS                                       ;A dispatch table from state,symbol
  GOTOS                                         ;A dispatch table from state,symbol
  INITIAL-STATE                                 ;State of top-level production
  LEFT-ASSOCIATIVE-TERMINALS                    ;Prefer reduce over shift
  RIGHT-ASSOCIATIVE-TERMINALS                   ;Prefer shift over reduce
  NON-ASSOCIATIVE-TERMINALS                     ;Give error if get to ambiguous state
  IGNORED-TERMINALS                             ;Unless otherwise handled
  PRECEDENCE-LIST                               ;List of lexemes, dummies or lists thereof
  LEXER                                         ;A function for producing list of terminals
  )

(DEFSTRUCT (PARSE-PRODUCTION :ARRAY :CONC-NAME (:ALTERANT NIL))
  SYMBOL                                        ;Input
  OUTPUT                                        ;List of symbols
  FUNCTION                                      ;Actual constructor
  PRECEDENCE                                    ;An element of the PRECEDENCE-LIST
  )

(DEFSTRUCT (PARSE-ITEM :LIST :CONC-NAME (:ALTERANT NIL))
  PRODUCTION                                    ;A PARSE-PRODUCTION
  POSITION                                      ;An NTHCDR of PARSE-PRODUCTION-OUTPUT of above
  TERMINAL                                      ;A lexeme or EOF
  )

;;; TABLE[SYMBOL,OFFSET]
(DEFUN MAKE-SYMBOL-DISPATCH (SYMBOLS WIDTH)
  (LOOP FOR SYMBOL IN SYMBOLS
        AS LIST = (MAKE-LIST (1+ WIDTH))
        DO (SETF (CAR LIST) SYMBOL)
        COLLECT LIST))

;;; GRAMMAR is supplied if this is the ACTIONS table
(DEFUN SET-SYMBOL-DISPATCH (VAL DISPATCH SYMBOL OFFSET &OPTIONAL GRAMMAR &AUX TEM OVAL)
  (OR (SETQ TEM (ASSQ SYMBOL DISPATCH))
      (FERROR NIL "~S not found in ~S" SYMBOL DISPATCH))
  (OR (AND (SETQ OVAL (NTH (1+ OFFSET) TEM))
           (NOT (EQUAL VAL OVAL))
           (COND ((NULL GRAMMAR)
                  (FERROR NIL "Parsing conflict and grammar not given"))
                 ((EQ OVAL '(ERROR))
                  T)                            ;Don't change ERROR
                 ((MEMQ SYMBOL (PARSE-GRAMMAR-NON-ASSOCIATIVE-TERMINALS GRAMMAR))
                  (SETQ VAL '(ERROR))
                  NIL)                          ;Do do setting if should be error
                 ((RESOLVE-PARSE-CONFLICT OVAL VAL SYMBOL OFFSET GRAMMAR)
                  NIL)                          ;Do setting if told to
                 (T
                  T)))                          ;Otherwise do not
      (SETF (NTH (1+ OFFSET) TEM) VAL)))

;;; This returns T if NEW should be substituted
(DEFUN RESOLVE-PARSE-CONFLICT (OLD NEW SYMBOL OFFSET GRAMMAR &AUX (T-FOR-NEW T) (ERROR-P T)
                               OLD-TYPE NEW-TYPE OLD-ARG NEW-ARG OLD-PREC NEW-PREC ALLOW-NEW)
  (SETQ OLD-TYPE (CAR OLD) OLD-ARG (CADR OLD))
  (SETQ NEW-TYPE (CAR NEW) NEW-ARG (CADR NEW))
  ;; If SHIFT-REDUCE conflict, make NEW be SHIFT and OLD be REDUCE
  (AND (EQ OLD-TYPE 'SHIFT) (EQ NEW-TYPE 'REDUCE)
       (PSETQ OLD NEW NEW OLD
              OLD-TYPE NEW-TYPE NEW-TYPE OLD-TYPE
              OLD-ARG NEW-ARG NEW-ARG OLD-ARG
              T-FOR-NEW NIL))
  ;; Can handle SHIFT-REDUCE or REDUCE-REDUCE conflicts
  (COND ((EQ OLD-TYPE 'REDUCE)
         (SETQ ERROR-P 'WARN)
         (SETQ OLD-PREC (PARSE-ACTION-PRECEDENCE OLD-TYPE OLD-ARG SYMBOL GRAMMAR)
               NEW-PREC (PARSE-ACTION-PRECEDENCE NEW-TYPE NEW-ARG SYMBOL GRAMMAR))
         (IF ( OLD-PREC NEW-PREC)
             (SETQ ERROR-P NIL
                   ALLOW-NEW (> NEW-PREC OLD-PREC))
             (AND (EQ NEW-TYPE 'SHIFT)
                  (COND ((MEMQ SYMBOL (PARSE-GRAMMAR-LEFT-ASSOCIATIVE-TERMINALS GRAMMAR))
                         (SETQ ERROR-P NIL
                               ALLOW-NEW NIL))  ;Prefer REDUCE
                        ((MEMQ SYMBOL (PARSE-GRAMMAR-RIGHT-ASSOCIATIVE-TERMINALS GRAMMAR))
                         (SETQ ERROR-P NIL
                               ALLOW-NEW T)))))))
  (COND (ERROR-P
         (FORMAT T "~&Warning: parsing conflict at state ~D for ~A, ambiguous grammar.
 Between " OFFSET SYMBOL)
         (PRINT-PARSE-ACTION OLD-TYPE OLD-ARG)
         (FORMAT T " and ")
         (PRINT-PARSE-ACTION NEW-TYPE NEW-ARG)
         (FORMAT T ".~% Preferring the ~:[latter~;former~] (left-associativity).~%"
                 (NOT ALLOW-NEW))
         (AND (EQ ERROR-P T) (FERROR NIL "Unresolvable parsing conflict."))))
  (EQ ALLOW-NEW T-FOR-NEW))

;;; Return the precedence of an action
(DEFUN PARSE-ACTION-PRECEDENCE (TYPE ARG SYMBOL GRAMMAR &AUX TERMINAL)
  (SETQ TERMINAL (SELECTQ TYPE
                   (SHIFT
                    SYMBOL)
                   (REDUCE
                    (OR (PARSE-PRODUCTION-PRECEDENCE ARG)
                        (LOOP FOR SYMBOL IN (PARSE-PRODUCTION-OUTPUT ARG)
                              WITH TERMINALS = (PARSE-GRAMMAR-TERMINALS GRAMMAR)
                              AND TEM
                              WHEN (MEMQ SYMBOL TERMINALS)
                              DO (SETQ TEM SYMBOL)
                              FINALLY (RETURN TEM))))))
  (LOOP WITH PRECEDENCE-LIST = (PARSE-GRAMMAR-PRECEDENCE-LIST GRAMMAR)
        FOR TERMINALS IN PRECEDENCE-LIST
        FOR I DOWNFROM (LENGTH PRECEDENCE-LIST)
        WHEN (IF (LISTP TERMINALS) (MEMQ TERMINAL TERMINALS) (EQ TERMINAL TERMINALS))
        DO (RETURN I)
        FINALLY (RETURN 0)))

(DEFUN PRINT-PARSE-ACTION (TYPE ARG)
  (SELECTQ TYPE
    (SHIFT
     (FORMAT T "Shift ~D" ARG))
    (REDUCE
     (FORMAT T "Reduce ~A  ~S" (PARSE-PRODUCTION-SYMBOL ARG) (PARSE-PRODUCTION-OUTPUT ARG)))
    (OTHERWISE
     (FORMAT T "~A~@[ ~S~]" TYPE ARG))))

(DEFUN SYMBOL-DISPATCH (DISPATCH SYMBOL OFFSET &AUX TEM)
  (AND (SETQ TEM (ASSQ SYMBOL DISPATCH))
       (NTH (1+ OFFSET) TEM)))

;;; This builds the ACTIONS and GOTOS tables for GRAMMAR
(DEFUN CONSTRUCT-PARSE-GRAMMAR-TABLES (GRAMMAR
                                       &AUX TERMINALS NONTERMINALS PARSE-ITEMS
                                            ACTIONS GOTOS INITIAL-STATE XSTATES WIDTH
                                            (DEFAULT-CONS-AREA COMPILER:FASD-TEMPORARY-AREA))
  (SETQ TERMINALS (PARSE-GRAMMAR-TERMINALS GRAMMAR)
        PARSE-ITEMS (PARSE-ITEMS GRAMMAR))
  (LOOP FOR L ON PARSE-ITEMS
        AS ITEMS = (CAR L)
        WITH INDEX = 0
        COLLECT (OR (LOOP FOR XL ON PARSE-ITEMS
                          UNTIL (EQ L XL)
                          AS X = (CAR XL)
                          FOR XINDEX FROM 0
                          WHEN (PARSE-CORE-EQUAL X ITEMS)
                          DO (RETURN (NTH XINDEX TEM)))
                    (PROG1 INDEX (SETQ INDEX (1+ INDEX))))
                INTO TEM
        FINALLY (SETQ WIDTH INDEX
                      XSTATES TEM))
  (LOOP FOR SYMBOL IN (PARSE-GRAMMAR-SYMBOLS GRAMMAR)
        UNLESS (MEMQ SYMBOL TERMINALS)
        COLLECT SYMBOL INTO TEM
        FINALLY (SETQ NONTERMINALS TEM
                      ACTIONS (MAKE-SYMBOL-DISPATCH TERMINALS WIDTH)
                      GOTOS (MAKE-SYMBOL-DISPATCH NONTERMINALS WIDTH)))
  (LOOP FOR ITEMS IN PARSE-ITEMS
        WITH TOP-LEVEL-PRODUCTION = (PARSE-GRAMMAR-TOP-LEVEL-PRODUCTION GRAMMAR)
        FOR XSTATE IN XSTATES
        DO (LOOP FOR ITEM IN ITEMS
                 WITH TEM
                 AS PRODUCTION = (PARSE-ITEM-PRODUCTION ITEM)
                 AND POSITION = (PARSE-ITEM-POSITION ITEM)
                 AND TERMINAL = (PARSE-ITEM-TERMINAL ITEM)
                 DO (COND ((EQ PRODUCTION TOP-LEVEL-PRODUCTION))
                          ((NULL POSITION)
                           (SET-SYMBOL-DISPATCH `(REDUCE ,PRODUCTION)
                                                ACTIONS TERMINAL XSTATE GRAMMAR))
                          ((MEMQ (SETQ TEM (CAR POSITION)) TERMINALS)
                           (LET* ((GOTO (PARSE-GOTO ITEMS TEM GRAMMAR))
                                  (OFFSET (FIND-POSITION-IN-LIST-PARSE-SET-EQUAL GOTO
                                                                               PARSE-ITEMS)))
                             (COND (OFFSET
                                    (SETQ OFFSET (NTH OFFSET XSTATES))
                                    (SET-SYMBOL-DISPATCH `(SHIFT ,OFFSET)
                                                         ACTIONS TEM XSTATE GRAMMAR))))))
                    (AND (EQ PRODUCTION TOP-LEVEL-PRODUCTION)
                         (IF (NULL POSITION)
                             (SET-SYMBOL-DISPATCH '(ACCEPT) ACTIONS 'EOF XSTATE GRAMMAR)
                             (SETQ INITIAL-STATE XSTATE))))
           (LOOP FOR SYMBOL IN NONTERMINALS
                 AS GOTO = (PARSE-GOTO ITEMS SYMBOL GRAMMAR)
                 AS OFFSET = (FIND-POSITION-IN-LIST-PARSE-SET-EQUAL GOTO PARSE-ITEMS)
                 WHEN OFFSET
                 DO (SET-SYMBOL-DISPATCH (NTH OFFSET XSTATES) GOTOS SYMBOL XSTATE)))
  ;; Now fill in everything else
  (LOOP FOR TABLE IN ACTIONS
        AS FILL = (IF (MEMQ (CAR TABLE) (PARSE-GRAMMAR-IGNORED-TERMINALS GRAMMAR))
                      '(DISCARD) '(ERROR))
        DO (LOOP FOR X ON (CDR TABLE)
                 WHEN (NULL (CAR X))
                 DO (SETF (CAR X) FILL)))
  (SETF (PARSE-GRAMMAR-ACTIONS GRAMMAR) (COPYTREE ACTIONS WORKING-STORAGE-AREA))
  (SETF (PARSE-GRAMMAR-GOTOS GRAMMAR) (COPYTREE GOTOS WORKING-STORAGE-AREA))
  (SETF (PARSE-GRAMMAR-INITIAL-STATE GRAMMAR) INITIAL-STATE)
  NIL)

;;; FIRST of a list of symbols
(DEFUN PARSE-FIRST (LIST GRAMMAR &AUX RESULT)
  (LOOP FOR SYMBOL IN LIST
        AS FIRST = (PARSE-FIRST-1 SYMBOL GRAMMAR)
        DO (LOOP FOR X IN FIRST
                 WHEN (NOT (NULL X))
                 DO (PUSH* X RESULT))
        ALWAYS (MEMQ 'NIL FIRST)
        FINALLY (PUSH* 'NIL RESULT))
  RESULT)

;;; FIRST of a single SYMBOL
(DEFUN PARSE-FIRST-1 (SYMBOL GRAMMAR)
  (IF (MEMQ SYMBOL (PARSE-GRAMMAR-TERMINALS GRAMMAR))
      (NCONS SYMBOL)
      (LOOP FOR PRODUCTION IN (PARSE-GRAMMAR-PRODUCTIONS GRAMMAR)
            WHEN (EQ (PARSE-PRODUCTION-SYMBOL PRODUCTION) SYMBOL)
            WITH OUTPUT AND RESULT AND TEM
            DO (SETQ OUTPUT (PARSE-PRODUCTION-OUTPUT PRODUCTION))
               (COND ((NULL OUTPUT)
                      (PUSH* 'NIL RESULT))
                     ((MEMQ (SETQ TEM (CAR OUTPUT)) (PARSE-GRAMMAR-TERMINALS GRAMMAR))
                      (PUSH* TEM RESULT))
                     (T
                      (LOOP FOR OSYMBOL IN OUTPUT
                            NEVER (MEMQ OSYMBOL (PARSE-GRAMMAR-TERMINALS GRAMMAR))
                            WHEN (NEQ OSYMBOL SYMBOL)
                            AS FIRST = (PARSE-FIRST-1 OSYMBOL GRAMMAR)
                            DO (LOOP FOR X IN FIRST
                                     WHEN (NOT (NULL X))
                                     DO (PUSH* X RESULT))
                            ALWAYS (MEMQ 'NIL FIRST)
                            FINALLY (PUSH* 'NIL RESULT))))
            FINALLY (RETURN RESULT))))

;;; CLOSURE of a set of items
(DEFUN PARSE-CLOSURE (ITEMS GRAMMAR)
  (LOOP FOR ITEM IN ITEMS
        WITH RESULT
        DO (SETQ RESULT (ADD-TO-PARSE-CLOSURE ITEM RESULT GRAMMAR))
        FINALLY (RETURN RESULT)))

(DEFUN ADD-TO-PARSE-CLOSURE (ITEM RESULT GRAMMAR)
  (COND ((NOT (MEMBER ITEM RESULT))
         (PUSH ITEM RESULT)
         (LOOP FOR PRODUCTION IN (PARSE-GRAMMAR-PRODUCTIONS GRAMMAR)
               WITH SYMBOL = (CAR (PARSE-ITEM-POSITION ITEM))
               AND TERMINALS = (PARSE-FIRST
                                 (APPEND (CDR (PARSE-ITEM-POSITION ITEM))
                                         (NCONS (PARSE-ITEM-TERMINAL
                                                 ITEM)))
                                  GRAMMAR)
               WHEN (EQ SYMBOL (PARSE-PRODUCTION-SYMBOL PRODUCTION))
               DO (LOOP FOR TERMINAL IN TERMINALS
                        DO (SETQ RESULT (ADD-TO-PARSE-CLOSURE
                                         (LIST PRODUCTION
                                               (PARSE-PRODUCTION-OUTPUT PRODUCTION)
                                               TERMINAL)
                                         RESULT GRAMMAR))))))
  RESULT)

;;; Compute possible next states from these
(DEFUN PARSE-GOTO (ITEMS SYMBOL GRAMMAR)
  (PARSE-CLOSURE (LOOP FOR ITEM IN ITEMS
                     WHEN (EQ (CAR (PARSE-ITEM-POSITION ITEM)) SYMBOL)
                     COLLECT (LIST (PARSE-ITEM-PRODUCTION ITEM)
                                   (CDR (PARSE-ITEM-POSITION ITEM))
                                   (PARSE-ITEM-TERMINAL ITEM)))
              GRAMMAR))

;;; Set of LALR(1) items for a grammar
(DEFUN PARSE-ITEMS (GRAMMAR)
  (LET ((PRODUCTION (PARSE-GRAMMAR-TOP-LEVEL-PRODUCTION GRAMMAR)))
    (ADD-PARSE-ITEMS (PARSE-CLOSURE (LIST (LIST PRODUCTION
                                            (PARSE-PRODUCTION-OUTPUT PRODUCTION)
                                            'EOF))
                               GRAMMAR)
                   NIL GRAMMAR)))

(DEFUN ADD-PARSE-ITEMS (ITEMS RESULT GRAMMAR)
  (COND ((NOT (MEM #'PARSE-SET-EQUAL ITEMS RESULT))
         (PUSH ITEMS RESULT)
         (LOOP FOR SYMBOL IN (PARSE-GRAMMAR-SYMBOLS GRAMMAR)
               AS GOTO = (PARSE-GOTO ITEMS SYMBOL GRAMMAR)
               WHEN (NOT (NULL GOTO))
               DO (SETQ RESULT (ADD-PARSE-ITEMS GOTO RESULT GRAMMAR)))))
  RESULT)

(DEFUN PARSE-SET-EQUAL (ITEMS1 ITEMS2)
  (AND (= (LENGTH ITEMS1) (LENGTH ITEMS2))
       (LOOP FOR ITEM IN ITEMS1
             ALWAYS (MEMBER ITEM ITEMS2))))

(DEFUN FIND-POSITION-IN-LIST-PARSE-SET-EQUAL (ITEMS LIST)
  (LOOP FOR X IN LIST
        FOR INDEX FROM 0
        WHEN (PARSE-SET-EQUAL X ITEMS)
        DO (RETURN INDEX)))

;;; Do these two sets of items differ only in associated terminals?
(DEFUN PARSE-CORE-EQUAL (ITEMS1 ITEMS2)
  (AND (PARSE-CORE-EQUAL-1 ITEMS1 ITEMS2)
       (PARSE-CORE-EQUAL-1 ITEMS2 ITEMS1)))

(DEFUN PARSE-CORE-EQUAL-1 (ITEMS1 ITEMS2)
  (LOOP FOR ITEM1 IN ITEMS1
        AS PRODUCTION = (PARSE-ITEM-PRODUCTION ITEM1)
        AND POSITION = (PARSE-ITEM-POSITION ITEM1)
        ALWAYS (LOOP FOR ITEM2 IN ITEMS2
                     THEREIS (AND (EQUAL PRODUCTION (PARSE-ITEM-PRODUCTION ITEM2))
                                  (EQUAL POSITION (PARSE-ITEM-POSITION ITEM2))))))

(DEFMACRO DEFINE-PARSE-GRAMMAR (NAME &BODY OPTIONS)
  (IF (AND COMPILER:QC-FILE-IN-PROGRESS (NOT COMPILER:QC-FILE-LOAD-FLAG))
      `(EVAL-WHEN (COMPILE)
         (REMPROP ',NAME 'COMPILE-PARSE-GRAMMAR)
         (DEFINE-PARSE-GRAMMAR-1 ',NAME ',(COPYLIST OPTIONS) 'COMPILE-PARSE-GRAMMAR))
      `(DEFINE-PARSE-GRAMMAR-1 ',NAME ',(COPYLIST OPTIONS) 'PARSE-GRAMMAR)))

(DEFUN DEFINE-PARSE-GRAMMAR-1 (NAME OPTIONS PROPNAME &AUX GRAMMAR NEW-P)
  (COND ((NULL (SETQ GRAMMAR (GET NAME PROPNAME)))
         (SETQ NEW-P T)
         (PUTPROP NAME (SETQ GRAMMAR (MAKE-PARSE-GRAMMAR NAME NAME))
                  PROPNAME)
         (LET ((TOP-LEVEL-PRODUCTION (MAKE-PARSE-PRODUCTION SYMBOL (GENSYM)
                                                            OUTPUT (NCONS NAME)
                                                            FUNCTION 'IDENTITY)))
           (SETF (PARSE-GRAMMAR-TOP-LEVEL-PRODUCTION GRAMMAR) TOP-LEVEL-PRODUCTION)
           (SETF (PARSE-GRAMMAR-PRODUCTIONS GRAMMAR) (LIST TOP-LEVEL-PRODUCTION)))))
  (LOOP FOR OPTION IN OPTIONS
        AS TYPE = (IF (LISTP OPTION) (CAR OPTION) OPTION)
        DO (SELECTQ TYPE
             (:LEXER
              (SETF (PARSE-GRAMMAR-LEXER GRAMMAR) (CADR OPTION)))
             (:LEXEMES
              (LET ((LEXEMES (CDR OPTION)))
                (SETF (PARSE-GRAMMAR-SYMBOLS GRAMMAR)
                      (IF NEW-P LEXEMES
                          (NCONC (LOOP WITH OLD = (PARSE-GRAMMAR-SYMBOLS GRAMMAR)
                                       FOR X IN LEXEMES
                                       WHEN (NOT (MEMQ X OLD))
                                       COLLECT X)
                                 (PARSE-GRAMMAR-SYMBOLS GRAMMAR))))
                (PUSH* 'EOF LEXEMES)
                (SETF (PARSE-GRAMMAR-TERMINALS GRAMMAR) LEXEMES)))
             (:LEFT-ASSOCIATIVE
              (SETF (PARSE-GRAMMAR-LEFT-ASSOCIATIVE-TERMINALS GRAMMAR)
                    (IF (LISTP OPTION) (CDR OPTION) T)))
             (:RIGHT-ASSOCIATIVE
              (SETF (PARSE-GRAMMAR-RIGHT-ASSOCIATIVE-TERMINALS GRAMMAR)
                    (IF (LISTP OPTION) (CDR OPTION) T)))
             (:NON-ASSOCIATIVE
              (SETF (PARSE-GRAMMAR-NON-ASSOCIATIVE-TERMINALS GRAMMAR)
                    (IF (LISTP OPTION) (CDR OPTION) T)))
             (:IGNORED
              (SETF (PARSE-GRAMMAR-IGNORED-TERMINALS GRAMMAR) (CDR OPTION)))
             (:PRECEDENCES
              (SETF (PARSE-GRAMMAR-PRECEDENCE-LIST GRAMMAR) (CDR OPTION)))
             (OTHERWISE
              (FERROR NIL "~S is not a known option" OPTION))))
  NAME)

(DEFUN IDENTITY (X) X)

(DEFMACRO ADD-PARSE-GRAMMAR-PRODUCTION ((NAME GRAMMAR) OUTPUT FUNCTION &BODY OPTIONS)
  (IF (AND COMPILER:QC-FILE-IN-PROGRESS (NOT COMPILER:QC-FILE-LOAD-FLAG))
      `(EVAL-WHEN (COMPILE)
         (ADD-PARSE-GRAMMAR-PRODUCTION-1 ',NAME ',GRAMMAR 'COMPILE-PARSE-GRAMMAR ',OUTPUT
                                         ',FUNCTION ',(COPYLIST OPTIONS)))
      `(ADD-PARSE-GRAMMAR-PRODUCTION-1 ',NAME ',GRAMMAR 'PARSE-GRAMMAR ',OUTPUT ',FUNCTION
                                       ',(COPYLIST OPTIONS))))

(DEFUN ADD-PARSE-GRAMMAR-PRODUCTION-1 (NAME GRAMMAR-NAME PROPNAME OUTPUT FUNCTION OPTIONS
                                       &AUX PRODUCTION GRAMMAR)
  (OR (SETQ GRAMMAR (GET GRAMMAR-NAME PROPNAME))
      (FERROR NIL "~A is not the name of a parse grammar" GRAMMAR-NAME))
  (PUSH* NAME (PARSE-GRAMMAR-SYMBOLS GRAMMAR))
  (COND ((NULL (SETQ PRODUCTION (LOOP FOR PRODUCTION IN (PARSE-GRAMMAR-PRODUCTIONS GRAMMAR)
                                      WHEN (AND (EQ (PARSE-PRODUCTION-SYMBOL PRODUCTION)
                                                    NAME)
                                                (EQUAL (PARSE-PRODUCTION-OUTPUT PRODUCTION)
                                                       OUTPUT))
                                      DO (RETURN PRODUCTION))))
         (SETQ PRODUCTION (MAKE-PARSE-PRODUCTION SYMBOL NAME
                                                 OUTPUT OUTPUT))
         (PUSH PRODUCTION (PARSE-GRAMMAR-PRODUCTIONS GRAMMAR))))
  (SETF (PARSE-PRODUCTION-FUNCTION PRODUCTION) FUNCTION)
  (LOOP FOR OPTION IN OPTIONS
        DO (SELECTQ (CAR OPTION)
             (:PRECEDENCE
              (SETF (PARSE-PRODUCTION-PRECEDENCE PRODUCTION) (CADR OPTION)))
             (OTHERWISE
              (FERROR NIL "~S is not a known option" OPTION)))))

(DEFVAR *PARSE-TRACE-P* NIL)

;;; Main parsing LALR function
;;; LIST is a list of lexeme-lists
(DEFUN PARSE-DRIVER (LIST GRAMMAR ERROR-P)
  (OR (PARSE-GRAMMAR-INITIAL-STATE GRAMMAR)
      (CONSTRUCT-PARSE-GRAMMAR-TABLES GRAMMAR))
  (LOOP WITH STATE = (PARSE-GRAMMAR-INITIAL-STATE GRAMMAR)
        WITH STACK = (NCONS STATE)
        AND ACTIONS = (PARSE-GRAMMAR-ACTIONS GRAMMAR)
        AND GOTOS = (PARSE-GRAMMAR-GOTOS GRAMMAR)
        AS TOKEN = (CAR LIST)
        AS ACTION = (SYMBOL-DISPATCH ACTIONS (CAR TOKEN) STATE)
        AS TYPE = (CAR ACTION)
        AND VALUE = (CADR ACTION)
        DO (COND (*PARSE-TRACE-P*
                  (LET ((PRINLENGTH 2) (PRINLEVEL 2))
                    (FORMAT T "~&~D, ~S: " STATE TOKEN))
                  (PRINT-PARSE-ACTION TYPE VALUE)
                  (FORMAT T "~%")))
           (SELECTQ TYPE
             (ERROR
              (RETURN (FUNCALL (IF ERROR-P #'FERROR #'FORMAT) NIL "Bad token ~S" TOKEN)))
             (ACCEPT
              (RETURN (EVAL (CADR STACK))))
             (DISCARD
              (SETQ LIST (CDR LIST)))
             (SHIFT
              (PUSH `',TOKEN STACK)
              (PUSH VALUE STACK)
              (SETQ STATE VALUE
                    LIST (CDR LIST)))
             (REDUCE
              (LOOP FOR FOO IN (PARSE-PRODUCTION-OUTPUT VALUE)
                    WITH ARGS = NIL
                    DO (POP STACK)
                    (PUSH (POP STACK) ARGS)
                    FINALLY (PUSH (CONS (PARSE-PRODUCTION-FUNCTION VALUE) ARGS)
                                  STACK)
                    (SETQ STATE (SYMBOL-DISPATCH GOTOS (PARSE-PRODUCTION-SYMBOL VALUE)
                                                 (CADR STACK)))
                    (PUSH STATE STACK))))))

(DEFUN PARSE (STRING GRAMMAR &OPTIONAL (START 0) END (ERROR-P T)
                             &AUX PARSE-GRAMMAR LEXER LEXEMES)
  (OR END (SETQ END (STRING-LENGTH STRING)))
  (OR (SETQ PARSE-GRAMMAR (GET GRAMMAR 'PARSE-GRAMMAR))
      (FERROR NIL "~A is not the name of a parse grammar" GRAMMAR))
  (OR (SETQ LEXER (PARSE-GRAMMAR-LEXER PARSE-GRAMMAR))
      (FERROR NIL "No lexer for ~S" PARSE-GRAMMAR))
  (SETQ LEXEMES (FUNCALL LEXER STRING START END ERROR-P))
  (IF (STRINGP LEXEMES)                         ;An error
      LEXEMES
      (PARSE-DRIVER LEXEMES PARSE-GRAMMAR ERROR-P)))

(DEFMACRO BUILD-PARSE-GRAMMAR (GRAMMAR)
  (IF (AND COMPILER:QC-FILE-IN-PROGRESS (NOT COMPILER:QC-FILE-LOAD-FLAG))
      (LET ((PARSE-GRAMMAR (GET GRAMMAR 'COMPILE-PARSE-GRAMMAR)))
        (CONSTRUCT-PARSE-GRAMMAR-TABLES PARSE-GRAMMAR)
        `(PUTPROP ',GRAMMAR ',PARSE-GRAMMAR 'PARSE-GRAMMAR))
      `(CONSTRUCT-PARSE-GRAMMAR-TABLES (GET ',GRAMMAR 'PARSE-GRAMMAR))))
